home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Mega Archive 1
/
Atari Mega Archive - Volume 1.iso
/
language
/
xlispsrc.arc
/
XLSTR.C
< prev
next >
Wrap
C/C++ Source or Header
|
1988-02-11
|
14KB
|
518 lines
/* xlstr - xlisp string and character built-in functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* local definitions */
#define fix(n) cvfixnum((FIXTYPE)(n))
#define TLEFT 1
#define TRIGHT 2
/* external variables */
extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
extern LVAL true;
extern char buf[];
/* external procedures */
extern char *strcat();
/* forward declarations */
FORWARD LVAL strcompare();
FORWARD LVAL chrcompare();
FORWARD LVAL changecase();
FORWARD LVAL trim();
/* string comparision functions */
LVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */
LVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */
LVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */
LVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */
LVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */
LVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */
/* string comparison functions (not case sensitive) */
LVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */
LVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */
LVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */
LVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */
LVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */
LVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */
/* strcompare - compare strings */
LOCAL LVAL strcompare(fcn,icase)
int fcn,icase;
{
int start1,end1,start2,end2,ch1,ch2;
unsigned char *p1,*p2;
LVAL str1,str2;
/* get the strings */
str1 = xlgastring();
str2 = xlgastring();
/* get the substring specifiers */
getbounds(str1,k_1start,k_1end,&start1,&end1);
getbounds(str2,k_2start,k_2end,&start2,&end2);
/* setup the string pointers */
p1 = &getstring(str1)[start1];
p2 = &getstring(str2)[start2];
/* compare the strings */
for (; start1 < end1 && start2 < end2; ++start1,++start2) {
ch1 = *p1++;
ch2 = *p2++;
if (icase) {
if (isupper(ch1)) ch1 = tolower(ch1);
if (isupper(ch2)) ch2 = tolower(ch2);
}
if (ch1 != ch2)
switch (fcn) {
case '<': return (ch1 < ch2 ? fix(start1) : NIL);
case 'L': return (ch1 <= ch2 ? fix(start1) : NIL);
case '=': return (NIL);
case '#': return (fix(start1));
case 'G': return (ch1 >= ch2 ? fix(start1) : NIL);
case '>': return (ch1 > ch2 ? fix(start1) : NIL);
}
}
/* check the termination condition */
switch (fcn) {
case '<': return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
case 'L': return (start1 >= end1 ? fix(start1) : NIL);
case '=': return (start1 >= end1 && start2 >= end2 ? true : NIL);
case '#': return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
case 'G': return (start2 >= end2 ? fix(start1) : NIL);
case '>': return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
}
}
/* case conversion functions */
LVAL xupcase() { return (changecase('U',FALSE)); }
LVAL xdowncase() { return (changecase('D',FALSE)); }
/* destructive case conversion functions */
LVAL xnupcase() { return (changecase('U',TRUE)); }
LVAL xndowncase() { return (changecase('D',TRUE)); }
/* changecase - change case */
LOCAL LVAL changecase(fcn,destructive)
int fcn,destructive;
{
unsigned char *srcp,*dstp;
int start,end,len,ch,i;
LVAL src,dst;
/* get the string */
src = xlgastring();
/* get the substring specifiers */
getbounds(src,k_start,k_end,&start,&end);
len = getslength(src) - 1;
/* make a destination string */
dst = (destructive ? src : newstring(len+1));
/* setup the string pointers */
srcp = getstring(src);
dstp = getstring(dst);
/* copy the source to the destination */
for (i = 0; i < len; ++i) {
ch = *srcp++;
if (i >= start && i < end)
switch (fcn) {
case 'U': if (islower(ch)) ch = toupper(ch); break;
case 'D': if (isupper(ch)) ch = tolower(ch); break;
}
*dstp++ = ch;
}
*dstp = '\0';
/* return the new string */
return (dst);
}
/* trim functions */
LVAL xtrim() { return (trim(TLEFT|TRIGHT)); }
LVAL xlefttrim() { return (trim(TLEFT)); }
LVAL xrighttrim() { return (trim(TRIGHT)); }
/* trim - trim character from a string */
LOCAL LVAL trim(fcn)
int fcn;
{
unsigned char *leftp,*rightp,*dstp;
LVAL bag,src,dst;
/* get the bag and the string */
bag = xlgastring();
src = xlgastring();
xllastarg();
/* setup the string pointers */
leftp = getstring(src);
rightp = leftp + getslength(src) - 2;
/* trim leading characters */
if (fcn & TLEFT)
while (leftp <= rightp && inbag(*leftp,bag))
++leftp;
/* trim character from the right */
if (fcn & TRIGHT)
while (rightp >= leftp && inbag(*rightp,bag))
--rightp;
/* make a destination string and setup the pointer */
dst = newstring((int)(rightp-leftp+2));
dstp = getstring(dst);
/* copy the source to the destination */
while (leftp <= rightp)
*dstp++ = *leftp++;
*dstp = '\0';
/* return the new string */
return (dst);
}
/* getbounds - get the start and end bounds of a string */
LOCAL getbounds(str,skey,ekey,pstart,pend)
LVAL str,skey,ekey; int *pstart,*pend;
{
LVAL arg;
int len;
/* get the length of the string */
len = getslength(str) - 1;
/* get the starting index */
if (xlgkfixnum(skey,&arg)) {
*pstart = (int)getfixnum(arg);
if (*pstart < 0 || *pstart > len)
xlerror("string index out of bounds",arg);
}
else
*pstart = 0;
/* get the ending index */
if (xlgkfixnum(ekey,&arg)) {
*pend = (int)getfixnum(arg);
if (*pend < 0 || *pend > len)
xlerror("string index out of bounds",arg);
}
else
*pend = len;
/* make sure the start is less than or equal to the end */
if (*pstart > *pend)
xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
}
/* inbag - test if a character is in a bag */
LOCAL int inbag(ch,bag)
int ch; LVAL bag;
{
unsigned char *p;
for (p = getstring(bag); *p != '\0'; ++p)
if (*p == ch)
return (TRUE);
return (FALSE);
}
/* xstrcat - concatenate a bunch of strings */
LVAL xstrcat()
{
LVAL *saveargv,tmp,val;
unsigned char *str;
int saveargc,len;
/* save the argument list */
saveargv = xlargv;
saveargc = xlargc;
/* find the length of the new string */
for (len = 0; moreargs(); ) {
tmp = xlgastring();
len += (int)getslength(tmp) - 1;
}
/* create the result string */
val = newstring(len+1);
str = getstring(val);
/* restore the argument list */
xlargv = saveargv;
xlargc = saveargc;
/* combine the strings */
for (*str = '\0'; moreargs(); ) {
tmp = nextarg();
strcat(str,getstring(tmp));
}
/* return the new string */
return (val);
}
/* xsubseq - return a subsequence */
LVAL xsubseq()
{
unsigned char *srcp,*dstp;
int start,end,len;
LVAL src,dst;
/* get string and starting and ending positions */
src = xlgastring();
/* get the starting position */
dst = xlgafixnum(); start = (int)getfixnum(dst);
if (start < 0 || start > getslength(src) - 1)
xlerror("string index out of bounds",dst);
/* get the ending position */
if (moreargs()) {
dst = xlgafixnum(); end = (int)getfixnum(dst);
if (end < 0 || end > getslength(src) - 1)
xlerror("string index out of bounds",dst);
}
else
end = getslength(src) - 1;
xllastarg();
/* setup the source pointer */
srcp = getstring(src) + start;
len = end - start;
/* make a destination string and setup the pointer */
dst = newstring(len+1);
dstp = getstring(dst);
/* copy